home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / scm / binsearch.scm < prev    next >
Encoding:
Text File  |  1993-10-01  |  4.4 KB  |  99 lines
  1.  
  2. (define archivio-environment
  3.         (make-environment
  4.         (define ord-test nil)
  5.         (define eq-test nil)
  6.         (define (qsort! v l)
  7.                 (define (interchange i j)
  8.                         (let ((t (vector-ref v i)))
  9.                              (vector-set! v i (vector-ref v j))
  10.                              (vector-set! v j t)))
  11.                 (define (qsort-i m n)
  12.                         (if (< m n)
  13.                             (do ((i m)
  14.                                  (j (1+ n))
  15.                                  (k (vector-ref v m)))
  16.                                 ((>= i j) (interchange m j)
  17.                                           (qsort-i m (-1+ j))
  18.                                           (qsort-i (1+ j) n))
  19.                                 (set! i (1+ i))
  20.                                 (do () 
  21.                                     ((or (ord-test (vector-ref v i) k) 
  22.                                          (>= i n)))
  23.                                     (set! i (1+ i)))
  24.                                 (set! j (-1+ j))
  25.                                 (do () 
  26.                                     ((or (ord-test k (vector-ref v j)) 
  27.                                          (<= j m)))
  28.                                     (set! j (-1+ j)))
  29.                                 (if (< i j)
  30.                                     (interchange i j)))))
  31.                 (qsort-i 0 l))
  32.         (define (binsearch x y n)
  33.                 (let ((m 0))
  34.                     (do ((mid (quotient (+ m n) 2)
  35.                               (quotient (+ m n) 2)))
  36.                         ((or (>= mid n) 
  37.                              (<= mid m)
  38.                              (eq-test y (vector-ref x mid)))
  39.                              (if (eq-test y (vector-ref x mid))
  40.                                  mid
  41.                                  nil))
  42.                         (if (ord-test y (vector-ref x mid))
  43.                             (set! m mid)
  44.                             (set! n mid)))))
  45.         (define (insert-el! x y n)
  46.                 (if (or (= n 0) (ord-test y (vector-ref x (-1+ n))))
  47.                     (vector-set! x n y)
  48.                     (begin (vector-set! x n (vector-ref x (-1+ n)))
  49.                            (insert-el! x y (-1+ n)))))
  50.         (define (make-dispatcher o-test e-test size)
  51.                 (define archivio (make-vector size nil))
  52.                 (define last-el 0)
  53.                 (define (dispatch message value)
  54.                         (cond ((eq? message 'save) 
  55.                                (let ((p (open-output-file value)))
  56.                                     (print archivio p)
  57.                                     (close-output-port p))
  58.                                #t)
  59.                               ((eq? message 'load)
  60.                                (let ((p (open-input-file value)))
  61.                                     (set! archivio (read p))
  62.                                     (close-input-port p))
  63.                                #t)
  64.                               ((eq? message 'add-el)
  65.                                (set! ord-test o-test)
  66.                                (insert-el! archivio value last-el)
  67.                                (set! last-el (1+ last-el))
  68.                                #t)
  69.                               ((eq? message 'add)
  70.                                (set! ord-test o-test)
  71.                                (vector-set! archivio last-el value)
  72.                                (set! last-el (1+ last-el))
  73.                                #t)
  74.                               ((eq? message 'last-el)
  75.                                last-el)
  76.                               ((eq? message 'read)
  77.                                (vector-ref archivio value))
  78.                               ((eq? message 'sort)
  79.                                (set! ord-test o-test)
  80.                                (qsort! archivio (-1+ last-el))
  81.                                #t)
  82.                               ((eq? message 'search) 
  83.                                (set! ord-test o-test)
  84.                                (set! eq-test e-test)
  85.                                (binsearch archivio value last-el))
  86.                               (else (error "unknown message: " message))))
  87.                 dispatch)))
  88.  
  89. (define standard-catalogo-size 100)
  90. (define standard-schedario-size 100)
  91.  
  92. (define (make-catalogo)
  93.         (eval (list 'make-dispatcher
  94.                     >
  95.                     =
  96.                     standard-catalogo-size)
  97.               archivio-environment))
  98.  
  99.